home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist01.zoo / lsp / turtles.lsp < prev   
Encoding:
Lisp/Scheme  |  1990-11-09  |  4.3 KB  |  194 lines
  1. (unless (fboundp 'defclass) (load 'classes))
  2.  
  3. ; This is a sample XLISP program
  4. ; It implements a simple form of programmable turtle for VT100 compatible
  5. ; terminals.
  6.  
  7. ; To run it:
  8.  
  9. ;    A>xlisp turtles
  10.  
  11. ; This should cause the screen to be cleared and two turtles to appear.
  12. ; They should each execute their simple programs and then the prompt
  13. ; should return.  Look at the code to see how all of this works.
  14.  
  15. ; Get some more memory
  16. (expand 1)
  17.  
  18. ; delay a while
  19. (setq Times 1000)
  20.  
  21. (defun delay ()
  22.     (dotimes (x Times) nil))
  23.  
  24.  
  25. ; Clear the screen
  26. (defun clear ()
  27.     (princ "\033[H\033[2J"))
  28.  
  29. ; Move the cursor
  30. (defun setpos (x y)
  31.     (princ "\033[") (princ y) (princ ";") (princ x) (princ "H"))
  32.  
  33. ; Kill the remainder of the line
  34. (defun kill ()
  35.     (princ "\033[K"))
  36.  
  37. ; Move the cursor to the currently set bottom position and clear the line
  38. ;  under it
  39. (defun bottom ()
  40.     (setpos *bx* (+ *by* 1))
  41.     (kill)
  42.     (setpos *bx* *by*)
  43.     (kill))
  44.  
  45. ; Clear the screen and go to the bottom
  46. (defun cb ()
  47.     (clear)
  48.     (bottom))
  49.  
  50.  
  51. ; ::::::::::::
  52. ; :: Turtle ::
  53. ; ::::::::::::
  54.  
  55. ; Define "Turtle" class
  56. (defclass Turtle ((xpos (setq *newx* (+ *newx* 1))) (ypos 12) (char "*")))
  57.  
  58. ; Message ":display" prints its char at its current position
  59. (defmethod Turtle :display () 
  60.     (setpos xpos ypos)
  61.     (princ char)
  62.     (bottom)
  63.     self)
  64.  
  65. ; When the character is set, we want to redisplay
  66. (defmethod Turtle :set-char (c)
  67.     (setq char c)
  68.     (send self :display))
  69.  
  70. ; Message ":char" sets char to its arg and displays it
  71. (defmethod Turtle :set-char (c) 
  72.     (setq char c)
  73.     (send self :display))
  74.  
  75. ; Message ":goto" goes to a new place after clearing old one
  76. (defmethod Turtle :goto (x y)
  77.     (setpos xpos ypos) (princ " ")
  78.     (setq xpos x)
  79.     (setq ypos y)
  80.     (send self :display))
  81.  
  82. ; Message ":up" moves up if not at top
  83. (defmethod Turtle :up ()
  84.     (if (> ypos 0)
  85.     (send self :goto xpos (- ypos 1))
  86.     (bottom)))
  87.  
  88. ; Message ":down" moves down if not at bottom
  89. (defmethod Turtle :down ()
  90.     (if (< ypos *by*)
  91.     (send self :goto xpos (+ ypos 1))
  92.     (bottom)))
  93.  
  94. ; Message ":right" moves right if not at right
  95. (defmethod Turtle :right ()
  96.     (if (< xpos 80)
  97.     (send self :goto (+ xpos 1) ypos)
  98.     (bottom)))
  99.  
  100. ; Message ":left" moves left if not at left
  101. (defmethod Turtle :left ()
  102.     (if (> xpos 0)
  103.     (send self :goto (- xpos 1) ypos)
  104.     (bottom)))
  105.  
  106. ; :::::::::::::::::::
  107. ; :: Circular-List ::
  108. ; :::::::::::::::::::
  109.  
  110.  
  111. ; Define a class to represent a circular list
  112. (defclass Circular-List (prog pc))
  113.  
  114. ; Replace :ISNEW with something more appropriate
  115. (defmethod Circular-List :ISNEW (&optional list)
  116.     (setf prog list pc list)
  117.     self)    ; return self
  118.  
  119. ; Method to get next item in list
  120. (defmethod Circular-list :next ()
  121.     (when (null pc) (setq pc prog))
  122.     (prog1 (car pc) (setq pc (cdr pc))))
  123.  
  124.  
  125. ; :::::::::::::
  126. ; :: PTurtle ::
  127. ; :::::::::::::
  128.  
  129. ; Define "PTurtle" programable turtle class
  130. (defclass PTurtle (prog) () Turtle)
  131.  
  132. ; Message ":program" stores a program
  133. (defmethod PTurtle :program (p)
  134.     (setf prog (send Circular-list :new p))
  135.     self)
  136.  
  137. ; Message ":step" executes a single program step
  138. (defmethod PTurtle :step () 
  139.     (when prog (send self (send prog :next)))
  140.     (delay)
  141.     self)
  142.  
  143. ; Message ":step#" steps each turtle program n times
  144. (defmethod PTurtle :step# (n)
  145.     (dotimes (x n) (send self :step))
  146.     self)
  147.  
  148.  
  149. ; ::::::::::::::
  150. ; :: PTurtles ::
  151. ; ::::::::::::::
  152.  
  153. ; Define "PTurtles" class
  154. (defclass PTurtles (Turtles))
  155.  
  156. ; Message ":make" makes a programable turtle and adds it to the collection
  157. (defmethod PTurtles :make (x y &aux newturtle)
  158.     (setq newturtle (send PTurtle :new :xpos x :ypos y))
  159.     (setq turtles (cons newturtle turtles))
  160.     newturtle)
  161.  
  162. ; Message ":step" steps each turtle program once
  163. (defmethod PTurtles :step ()
  164.     (mapcar #'(lambda (Turtle) (send Turtle :step)) Turtles)
  165.     self)
  166.  
  167. ; Message ":step#" steps each turtle program n times
  168. (defmethod PTurtles :step# (n)
  169.     (dotimes (x n) (send self :step))
  170.     self)
  171.  
  172.  
  173. ; Initialize things and start up
  174. (setq *bx* 0)
  175. (setq *by* 20)
  176. (setq *newx* 0)
  177.  
  178. ; Create some programmable turtles
  179. (cb)
  180. (definst PTurtles Turtles)
  181. (setq t1 (send Turtles :make 40 10))
  182. (setq t2 (send Turtles :make 41 10))
  183. (send t1 :program '(:left :left :right :right :up :up :down :down))
  184. (send t2 :program '(:right :right :down :down :left :left :up :up))
  185. (send t1 :set-char "+")
  186. (defun doit () 
  187.     (progn
  188.         (cb)
  189.         (send t1 :step# 8)
  190.         (send t2 :step# 8)
  191.         (send turtles :step# 8)))
  192. (doit)
  193.  
  194.